PC Pro 1997 July/PC Pro July 1997.iso/extras/code/visprog32.txt

Text File | 1997-04-28 | 5.6 KB | 207 lines

Listing One

procedure TExplorerButton.WMRButtonDown (var Message: TWMRButtonDown);
begin
    { Disable AutoPopup before calling Inherited }
    if PopupMenu <> Nil then PopupMenu.AutoPopup := False;
    Inherited;
end;

procedure TExplorerButton.WMLButtonDown (var Message: TWMLButtonDown);
var
    pt: TPoint;
    InControl: Boolean;
begin
    Inherited;
    InControl := PtInRect (GetClientRect, Point (Message.XPos, Message.YPos));

    if InControl then
    begin
        MouseCapture := True;
        fState := bsDown;
        Invalidate;

        if PopupMenu <> Nil then
        begin
            pt := Parent.ClientToScreen (Point (Left - 1, Top + Height));
            PopupMenu.Alignment := paLeft;
            PopupMenu.PopupComponent := Self;
            PopupMenu.Popup (pt.x, pt.y);
            fState := bsInactive;
            MouseCapture := False;
            Invalidate;
        end;
    end;
end;

Listing Two

procedure TExplorerButton.Paint;
var
    x, y: Integer;
    Glyph: TBitmap;
    txtRect, bitRect, glyphRect: TRect;

    procedure DrawMenuGlyph (x, y: Integer; Color: TColor; Style: TBrushStyle);
    begin
        with Canvas do
        begin
            Pen.Color := Color;
            Brush.Color := clBlack;
            Brush.Style := Style;
            Canvas.Polygon([Point (x, y), Point (x + 8, y), Point (x + 4, y + 4)]);
        end;
    end;

begin
    with Canvas do
    begin
        ╔<<< drawing code as shown last month>>>╔

        { Draw the drop-down menu 'glyph' }
        if PopupMenu <> Nil then
        begin
            x := Width - 14; y := 4;
            if Enabled then
            begin
                if fState = bsDown then begin Inc (x); Inc (y); end;
                DrawMenuGlyph (x, y, clBlack, bsSolid);
            end
            else
            begin
                DrawMenuGlyph (x, y, clBtnShadow, bsClear);
                DrawMenuGlyph (x + 1, y + 1, clBtnHighlight, bsClear);
            end;
        end;

        { Finally, draw the glyph }
        Brush.Color := Color;
        BrushCopy (bitRect, Glyph, glyphRect, fTransparentColor);
    end;
end;

Listing Three

unit CoolBar;

interface

uses Messages, Windows, Classes, Controls, Forms, SysUtils, CommCtrl;

function AddCoolBar (Wnd: hWnd): hWnd;
procedure AlignCoolBar (CoolBarWnd: hWnd);
procedure AddBand (CoolBarWnd: hWnd; Comp: TWinControl);

implementation

const
    ICC_Cool_Classes        =     $00000400;
    RBS_VarHeight        =     $00000200;
    RBS_BandBorder        =     $00000400;
    RBBS_ChildEdge        =     $00000004;
    RBBS_FixedBmp        =     $00000020;
    RBBIM_Style            =     $00000001;
    RBBIM_Colors        =     $00000002;
    RBBIM_Child            =     $00000010;
    RBBIM_ChildSize        =     $00000020;
    RB_InsertBand        =     wm_User +1;

    ReBarClassName              =     'ReBarWindow32';

type
    TICCEx = record
                 dwSize: DWord;
                 dwFlags: DWord;
             end;

    TRebarInfo = record
                     cbSize: UInt;
                     fMask: UInt;
                     fStyle: UInt;
                     himl: HImageList;
                     hbmBack: HBitmap;
                 end;

    TRebarBandInfo = record
                         cbSize: UInt;
                         fMask: UInt;
                         fStyle: UInt;
                         clrFore: TColorRef;
                         clrBack: TColorRef;
                         lpText: PChar;
                         cch: UInt;
                         iImage: Integer;
                         hWndChild: hWnd;
                         cxMinChild: UInt;
                         cyMinChild: UInt;
                         cx: UInt;
                         hbmBack: hBitmap;
                         wID: UInt;
                     end;

function InitCommonControlsEx (var ICCRec: TICCEx): Boolean; stdcall; external 'COMCTL32.DLL';

procedure CoolBarInit;
var
    ICCRec: TICCEx;
begin
    ICCRec.dwSize := sizeof (ICCRec);
    ICCRec.dwFlags := ICC_Cool_Classes;
    InitCommonControlsEx (ICCRec);
end;

procedure AlignCoolBar (CoolBarWnd: hWnd);
var
    rcForm: TRect;
begin
    GetClientRect (GetParent (CoolBarWnd), rcForm);
    MoveWindow (CoolBarWnd, 0, 0, rcForm.right, rcForm.Bottom, True);
end;

procedure AddBand (CoolBarWnd: hWnd; Comp: TWinControl);
var
    rc: TRect;
    rbbi: TRebarBandInfo;
begin
    FillChar (rbbi, sizeof (rbbi), 0);
    GetWindowRect (Comp.Handle, rc);

    with rbbi do
    begin
        cbSize := sizeof (rbbi);
        fMask := RBBIM_Child or RBBIM_ChildSize or RBBIM_Style or RBBIM_Colors;
        cxMinChild := 50; { Maybe pass this as a parameter? }
        cyMinChild := rc.bottom - rc.top;
        clrFore := GetSysColor (Color_BtnText);
        clrBack := GetSysColor (Color_BtnFace);
        fStyle := RBBS_ChildEdge or RBBS_FixedBmp;
        hwndChild := Comp.Handle;
        iImage := 0;
    end;

    SendMessage (CoolBarWnd, RB_InsertBand, -1, LongInt (@rbbi));
    AlignCoolBar (CoolBarWnd);
end;

function AddCoolBar (Wnd: hWnd): hWnd;
var
    style: DWord;
begin
    style := ws_Visible or ws_Child or ws_Border or ws_ClipChildren or ws_ClipSiblings;
    style := style or RBS_VarHeight or rbs_BandBorder;
    style := style or CCS_NoDivider or CCS_NoParentAlign;

    Result := CreateWindowEx (ws_ex_ToolWindow, ReBarClassName,
                              Nil, style, 0, 0, 200, 100, Wnd,
                              0, hInstance, Nil);
end;

{ Initialisation code for the unit }

begin
    CoolBarInit;
end.